home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / error.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  21KB  |  724 lines
  1. /* ******************************************************************** */
  2. /*  error.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Error and Signal handling                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *    Added names of the defined conditions - JPff
  11.  *   Version 2, May 1989
  12.  *    Amalgamated with section condition.c for sanity
  13.  *   Version 3, May 1989
  14.  *      Updated for new ideas on handlers/restarts - RJB
  15.  *      Integrated conditions into the object system - KJP
  16.  *   Version 4, June 1990
  17.  *      Rewrote handlers and signals correctly - KJP
  18.  *        - with-handler special 
  19.  *        - generally rearranged 
  20.  */
  21.  
  22. #include <stdio.h>
  23. #include <string.h>
  24. #include "defs.h"
  25. #include "structs.h"
  26. #include "funcalls.h"
  27.  
  28. #include "global.h"
  29. #include "error.h"
  30.  
  31. #include "bootstrap.h"
  32. #include "slots.h"
  33. #include "class.h"
  34.  
  35. #include "symboot.h"
  36. #include "modules.h"
  37. #include "specials.h"
  38. #include "modboot.h"
  39. #include "ngenerics.h"
  40. #include "calls.h"
  41.  
  42. #include "state.h"
  43.  
  44. #define N_SLOTS_IN_CONDITION 2
  45. /* The error system classes... */
  46.  
  47. LispObject Condition_Class; 
  48. LispObject Default_Condition;
  49.  
  50. /* Array for pre-defind conditions... */
  51.  
  52. LispObject defined_conditions; /* a vector of junk */
  53.  
  54. extern LispObject unbound;
  55.  
  56. /*
  57.  * Conditions...
  58.  * Includes generation and defined slot access... 
  59.  */
  60.  
  61. /* Predicate... */
  62.  
  63. EUFUN_1( Fn_conditionp, form)
  64. {
  65.   return (is_condition(form) ? lisptrue : nil);
  66. }
  67. EUFUN_CLOSE
  68.  
  69. /* Generator... */
  70.  
  71. EUFUN_2( Fn_make_condition, class, initlist)
  72. {
  73.   LispObject ans;
  74.   
  75.   EUCALLSET_2(ans, Fn_subclassp, classof(class),Condition_Class);
  76.   if (ans==nil)
  77.     CallError(stackbase, "make-condition: non condition class",
  78.           ARG_0(stackbase),NONCONTINUABLE);
  79.  
  80.   return(Gf_make_instance(stackbase));
  81.  
  82. }
  83. EUFUN_CLOSE
  84.  
  85. /*
  86.  
  87.  * Built in condition slot accessors...
  88.  
  89. */
  90.  
  91. EUFUN_1( Fn_condition_name, cond)
  92. {
  93.  
  94.   if (!is_condition(cond))
  95.     CallError(stackbase,"condition-name: not a condition",cond,NONCONTINUABLE);
  96.  
  97.   return classof(cond)->CLASS.name;
  98. }
  99. EUFUN_CLOSE
  100.  
  101. EUFUN_1( Fn_condition_message, cond)
  102. {
  103.  
  104.   if (!is_condition(cond))
  105.     CallError(stackbase,
  106.           "condition-message: not a condition",cond,NONCONTINUABLE);
  107.  
  108.   return(condition_message(cond));
  109. }
  110. EUFUN_CLOSE
  111.  
  112. EUFUN_1( Fn_condition_error_value, cond)
  113. {
  114.  
  115.   if (!is_condition(cond))
  116.     CallError(stackbase,
  117.           "condition-error-value: not a condition",cond,NONCONTINUABLE);
  118.  
  119.   return(condition_error_value(cond));
  120. }
  121. EUFUN_CLOSE
  122.  
  123. /* 
  124.  * Signals and Handlers...
  125.  */
  126.  
  127. /* Heap collapse... */
  128.  
  129. void signal_heap_failure(LispObject *stackbase, int type)
  130. {
  131.   extern LispObject Fn_abort_thread(LispObject*);
  132.   extern LispObject interpreter_thread;
  133.   extern LispObject read_eval_print_continue;
  134.   
  135.   fprintf(StdErr->STREAM.handle,
  136.       "\nTrapping heap exhaustion condition on type %x\n\n",type);
  137.   
  138. #ifndef MACHINE_ANY
  139.  
  140.   if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  141.     fprintf(StdErr->STREAM.handle,
  142.         "Calculation abandoned - returning to top level...\n\n");
  143.     call_continue(stackbase,CAR(read_eval_print_continue),lisptrue);
  144.   }
  145.  
  146.   fprintf(StdErr->STREAM.handle,
  147.       "Thread aborting - wait for other failures...\n\n");
  148.   (void) Fn_abort_thread(stackbase);
  149.  
  150. #else
  151.  
  152.   fprintf(StdErr->STREAM.handle,
  153.       "Calculation abandoned - returning to top level...\n\n");
  154.   call_continue(stackbase,CAR(read_eval_print_continue),lisptrue);
  155.  
  156. #endif
  157. }
  158.  
  159. /* Prompt string... */
  160.  
  161. #define MAX_PROMPT_LENGTH (1024)
  162. char current_prompt_string[MAX_PROMPT_LENGTH];
  163.   
  164. /* Default signal handling... */
  165.  
  166. static LispObject sym_pling_backtrace;
  167. static LispObject sym_pling_b;
  168. static LispObject sym_pling_quickie;
  169. static LispObject sym_pling_q;
  170. LispObject sym_pling_exit; 
  171. LispObject sym_pling_root;
  172.  
  173. extern LispObject Gf_generic_write(LispObject*);
  174.  
  175. void condition_handler(LispObject *stackbase, LispObject cond,LispObject cont)
  176. {
  177.   extern 
  178.     SYSTEM_THREAD_SPECIFIC_DECLARATION(int,system_scheduler_number);
  179.   extern 
  180.     LispObject Gf_generic_prin(LispObject*);
  181.   extern
  182.     void module_eval_backtrace(LispObject *);
  183.   extern
  184.     void quickie_module_eval_backtrace(LispObject *);
  185.   extern
  186.     LispObject get_history_form(LispObject);
  187.   extern
  188.     void put_history_form(LispObject*, LispObject);
  189.   extern
  190.     int get_history_count(void);
  191.  
  192.   LispObject *stacktop = stackbase;
  193.   LispObject form,value;
  194.   LispObject *gc_index = GC_STACK_POINTER();
  195.  
  196.   while (TRUE) {
  197.     sprintf(current_prompt_string,"eulisp-handler:%x:%s!%d> ",
  198.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number),
  199.         stringof(SYSTEM_GLOBAL_VALUE(current_interactive_module)
  200.              ->I_MODULE.name->SYMBOL.pname),
  201.         get_history_count());
  202. /*
  203.     fprintf(StdErr->STREAM.handle,"eulisp-handler:%x:",
  204.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number));
  205.     EUCALL_2(Gf_generic_prin,
  206.              SYSTEM_GLOBAL_VALUE(current_interactive_module)->I_MODULE.name,
  207.          StdErr);
  208.     fprintf(StdErr->STREAM.handle,"!%d> ",get_history_count());
  209. */
  210.  
  211. #ifndef GNUREADLINE
  212.     fprintf(StdErr->STREAM.handle,"%s",current_prompt_string);
  213. #endif
  214.  
  215.     EUCALLSET_1(form, Fn_read, StdIn);
  216.     form = get_history_form(form);
  217.     put_history_form(stacktop, form);
  218.  
  219.     if (form == sym_pling_exit || form == q_eof) return;
  220.     if (form == sym_pling_root) {
  221.       SYSTEM_GLOBAL_VALUE(current_interactive_module) =
  222.     get_module(stacktop,sym_root);
  223.       value = nil;
  224.     } 
  225.     else if (form == sym_pling_backtrace || form == sym_pling_b) {
  226.       module_eval_backtrace(stacktop);
  227.       value = nil;
  228.     }
  229.     else if (form == sym_pling_quickie || form == sym_pling_q) {
  230.       quickie_module_eval_backtrace(stacktop);
  231.       value = nil;
  232.     }
  233.     else
  234.       EUCALLSET_2(value,process_top_level_form,
  235.            SYSTEM_GLOBAL_VALUE(current_interactive_module),
  236.            form);
  237.  
  238.     fprintf(StdErr->STREAM.handle,"eulisp-handler:%x:",
  239.         SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number));
  240.     STACK_TMP(value);
  241.     EUCALL_2(Gf_generic_prin, SYSTEM_GLOBAL_VALUE(current_interactive_module)
  242.            ->I_MODULE.name,StdErr);
  243.     fprintf(StdErr->STREAM.handle,"!%d< ",get_history_count()-1);
  244.  
  245.     UNSTACK_TMP(value);
  246.     EUCALL_2(Gf_generic_write,value,StdErr);
  247.     fprintf(StdErr->STREAM.handle,"\n\n");
  248.   }
  249. }
  250.  
  251. LispObject function_bootstrap_handler;
  252. EUFUN_2( Fn_bootstrap_handler, cond, cont)
  253. {
  254.   LispObject slots;
  255.  
  256.   /* Check for dumb errors... */
  257.  
  258.   if (!is_condition(cond))
  259.     CallError(stackbase,
  260.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  261.  
  262.   if (!is_continue(cont) && cont != nil)
  263.     CallError(stackbase,"Invalid continuation in default handler",cont,
  264.           NONCONTINUABLE);
  265.  
  266.   /* Now, display error message... */
  267.  
  268.   fprintf(stderr,"\nCompiled Elvira initialisation code error!!!\n"); 
  269.  
  270.   fprintf(stderr,"\nTrapping unhandled "); 
  271.   if (cont == nil)
  272.     fprintf(stderr,"non-continuable \"");
  273.   else
  274.     fprintf(stderr,"continuable \"");
  275.  
  276.   fprintf(stderr,"error\"");
  277.   fprintf(stderr,"Check for initcode module --- It is needed\n");
  278.   system_lisp_exit(1);
  279.   
  280.   return(nil);            /* dummy return */
  281. }
  282. EUFUN_CLOSE
  283.  
  284. LispObject function_default_handler;
  285. EUFUN_2( Fn_default_handler, cond, cont)
  286. {
  287.   LispObject slots;
  288.  
  289.   /* Check for dumb errors... */
  290.  
  291.   if (!is_condition(cond))
  292.     CallError(stackbase,
  293.           "Default Handler not given a condition",cond,NONCONTINUABLE);
  294.  
  295.   if (!is_continue(cont) && cont != nil)
  296.     CallError(stackbase,"Invalid continuation in default handler",cont,
  297.           NONCONTINUABLE);
  298.  
  299.   /* Now, display error message... */
  300.  
  301.   /* Should check if it's a heap error... */
  302.  
  303.   fprintf(stderr,"\nTrapping unhandled "); 
  304.   if (cont == nil)
  305.     fprintf(stderr,"non-continuable \"");
  306.   else
  307.     fprintf(stderr,"continuable \"");
  308.   EUCALL_2(Gf_generic_write,classof(cond)->CLASS.name,StdErr);
  309.   fprintf(stderr,"\"\n\n");
  310.   cond = ARG_0(stackbase);
  311.   if (condition_message(cond) != nil) {
  312.     fprintf(stderr,"message: ");
  313.     EUCALL_2(Gf_generic_write,condition_message(cond),StdErr);
  314.     fprintf(stderr,"\n");
  315.     cond = ARG_0(stackbase);
  316.   }
  317.   if (condition_error_value(cond) != unbound) {
  318.     fprintf(stderr,"error-value: ");
  319.     EUCALL_2(Gf_generic_write,condition_error_value(cond),StdErr);
  320.     fprintf(stderr,"\n");
  321.     cond = ARG_0(stackbase);
  322.   }
  323.  
  324.   /* Display the slot contents with names */
  325.  
  326.   if (cond->CLASS.slot_table != nil) {
  327.     EUCALLSET_1(slots, Fn_class_slot_descriptions,classof(cond));
  328.     while (slots != nil) {
  329.       extern LispObject generic_slot_value_using_slot_description;
  330.       LispObject xx;
  331.  
  332.       LispObject desc = CAR(slots);
  333.  
  334.       slots = CDR(slots);
  335.       STACK_TMP(slots); STACK_TMP(desc);
  336.       EUCALLSET_1(xx, Fn_slot_description_name, desc);
  337.       EUCALL_2(Gf_generic_write, xx,StdErr);
  338.       fprintf(stderr,": ");
  339.       UNSTACK_TMP(desc);
  340.       cond = ARG_0(stackbase);
  341.       xx = generic_apply_2(stacktop,
  342.                generic_slot_value_using_slot_description,
  343.                cond, desc);
  344.       EUCALL_2(Gf_generic_write,xx,StdErr);
  345.       fprintf(stderr,"\n");
  346.       UNSTACK_TMP(slots);
  347.     }
  348.   }
  349.  
  350.   fprintf(StdErr->STREAM.handle,"\n");
  351.   fflush(StdIn->STREAM.handle);
  352.  
  353.   {
  354.     extern void module_eval_backtrace(LispObject *);
  355.     extern LispObject Fn_abort_thread(LispObject *);
  356.     extern LispObject read_eval_print_continue;
  357.     extern LispObject interpreter_thread;
  358.     extern void call_continuation(LispObject*,LispObject,LispObject);
  359.  
  360.     /* Go for auto-backtrace on weird threads */
  361.  
  362.     cond = ARG_0(stackbase);
  363.     cont = ARG_1(stackbase);
  364.     if (CURRENT_THREAD() == CAR(interpreter_thread)) {
  365.       fprintf(StdErr->STREAM.handle,"Entering condition handler...\n\n");
  366.       condition_handler(stacktop,cond,cont);
  367.       fprintf(StdErr->STREAM.handle,"\nReturning to top level...\n\n");
  368.       call_continuation(stacktop,CAR(read_eval_print_continue),nil);
  369.     }
  370. #ifndef MACHINE_ANY
  371.     
  372.     fprintf(StdErr->STREAM.handle,"ABORTING THREAD: ");
  373.     EUCALL_2(Gf_generic_write,CURRENT_THREAD(),StdErr);
  374.     fprintf(StdErr->STREAM.handle,"\n\nBacktrace follows...\n");
  375.     module_eval_backtrace(stacktop);
  376.     fprintf(StdErr->STREAM.handle,"Thread aborted.\n\n");
  377.     (void) Fn_abort_thread(stacktop);
  378.  
  379. #endif
  380.  
  381.   }
  382.  
  383.   return(nil);            /* dummy return */
  384. }
  385. EUFUN_CLOSE
  386.  
  387. /* User signal function... */
  388.  
  389. EUFUN_2( Fn_signal, cond, cont)
  390. {
  391.   LispObject stack;
  392.  
  393.   if (cont != nil && !is_continue(cont))
  394.     CallError(stackbase,"signal: non continuation",cont,NONCONTINUABLE);
  395.  
  396.   if (!is_condition(cond))
  397.     CallError(stackbase,"signal: not a condition",cond,NONCONTINUABLE);
  398.  
  399.   /* OK, grab a handler and do the business... */
  400.  
  401.   /* Here be strangeness - handlers are executed in the handler environment
  402.      of their establishment => (I think) just decrementing the handler stack
  403.      as we run along - continuations will re-instate, but keep a copy for
  404.      GC safety... */
  405.  
  406.   stack = HANDLER_STACK();
  407.  
  408.   STACK_TMP(stack);
  409.   
  410.   while (is_cons(HANDLER_STACK())) {
  411.     LispObject handle;
  412.  
  413.     handle = CAR(HANDLER_STACK()); 
  414.     HANDLER_STACK() = CDR(HANDLER_STACK());
  415.  
  416.     /* Need this 'cos apply allocates... */
  417.     
  418.     if (handle == function_default_handler)
  419.       EUCALL_2(Fn_default_handler,cond,cont);
  420.     else
  421.       EUCALL_3(apply2,handle,cond,cont);
  422.     cond = ARG_0(stackbase);
  423.     cont = ARG_1(stackbase);
  424.  
  425.     /* Back here means try again... */
  426.   }
  427.  
  428.   /* Ack! No handler accepted!! */
  429.  
  430.   UNSTACK_TMP(stack);
  431.  
  432.   HANDLER_STACK() = stack;
  433.  
  434.   return(cond);
  435. }
  436. EUFUN_CLOSE
  437.  
  438. /*
  439.  * Internally used error handling and signalling...
  440.  */
  441.  
  442. /* Signal condition i with message and one value... */
  443.  
  444. /* Emergency heap condition... */
  445.  
  446. LispObject condition_heap_exhausted;
  447.  
  448. void signal_message(LispObject *stackbase, int i,char *message,LispObject val)
  449. {
  450.   LispObject cond_class;
  451.   LispObject cond;
  452.   LispObject *stacktop = stackbase;
  453.   STACK_TMP(val);
  454.  
  455.   /* Special case if out of heap... */
  456.  
  457.   if (i == HEAP_EXHAUSTED) {
  458.     cond = condition_heap_exhausted;
  459.     fprintf(StdErr->STREAM.handle,"Heap wimped out!! Rats.\n");
  460.     system_lisp_exit(1);
  461.   }
  462.   else {
  463.     cond_class = vref(defined_conditions,i)->SYMBOL.lvalue;
  464.     cond = (LispObject) allocate_instance(stacktop,cond_class);
  465.   }
  466.   STACK_TMP(cond);
  467.   condition_message(cond) = 
  468.     (LispObject) allocate_string(stacktop,message,strlen(message));
  469.   UNSTACK_TMP(cond);
  470.   UNSTACK_TMP(val);
  471.   condition_error_value(cond) = val;
  472.  
  473.   STACK_TMP(cond);
  474.   EUCALL_2(Fn_signal,cond,nil);
  475.   UNSTACK_TMP(cond);
  476.  
  477.   /* Returned => call default... */
  478.  
  479.   EUCALL_2(Fn_default_handler,cond,nil);
  480.  
  481.   /* Returned means deep trouble... */
  482.  
  483.   fprintf(stderr,"INTERNAL ERROR: signal returned on internal call\n");
  484.   fprintf(stderr,"Message was: '%s'\n",message); fflush(stderr);
  485.  
  486.   system_lisp_exit(1);
  487. }
  488.  
  489.  
  490. LispObject CallError(LispObject *stackbase, char *format,LispObject x,int type)
  491. {
  492.   IGNORE(type);
  493.  
  494.   signal_message(stackbase, INTERNAL_ERROR,format,x);
  495.   return(nil);
  496. }
  497.  
  498. EUFUN_3( Fn_cerror, message, cond, args)
  499. {
  500.   LispObject cont,val;
  501.  
  502.   cont = (LispObject) allocate_continue(stackbase);
  503.  
  504.   if (set_continue(stacktop,cont)) return(cont->CONTINUE.value);
  505.  
  506.   STACK_TMP(cont);
  507.   message = ARG_0(stackbase);
  508.   args = ARG_2(stackbase);
  509.   EUCALLSET_2(message, Fn_cons, message, args);
  510.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  511.   cond = ARG_1(stackbase);
  512.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  513.   UNSTACK_TMP(cont);
  514.   EUCALLSET_2(val, Fn_signal, message, cont);
  515.   call_continue(stacktop,cont,val);
  516.   return(val);
  517. }
  518. EUFUN_CLOSE
  519.  
  520. EUFUN_3( Fn_error, message, cond, args)
  521. {
  522.   LispObject val;
  523.  
  524.   EUCALLSET_2(message, Fn_cons, message, args);
  525.   EUCALLSET_2(message, Fn_cons, sym_message, message);
  526.   cond = ARG_1(stackbase);
  527.   EUCALLSET_2(message, Fn_make_condition, cond, message);
  528.   EUCALLSET_2(val, Fn_signal, message, nil);
  529.   return(val);
  530. }
  531. EUFUN_CLOSE
  532.  
  533. /* *************************************************************** */
  534. /* Initialisation of this section                                  */
  535. /* *************************************************************** */
  536.  
  537. #define ERRORS_ENTRIES 10
  538. MODULE Module_errors;
  539. LispObject Module_errors_values[ERRORS_ENTRIES];
  540.  
  541. void initialise_error(LispObject *stacktop)
  542. {
  543.  
  544.   static char* inits[] = {
  545.     "Internal-Error",        /* INTERNAL_ERROR */
  546.  
  547.     "unbound-lexical-variable",    /* UNBOUND_LEXICAL_VARIABLE */
  548.     "unbound-dynamic-variable",    /* UNBOUND_DYNAMIC_VARIABLE */
  549.     "invalid-operator",        /* INVALID_OPERATOR */
  550.     "no-update-function",    /* NO_UPDATE_FUNCTION */
  551.     "immutable-binding",    /* IMMUTABLE_BINDING */
  552.     "no-block-for-return",    /* NO_BLOCK_FOR_RETURN */
  553.     "no-catch-for-throw",    /* NO_CATCH_FOR_THROW */
  554.  
  555.     "clock-tick",        /* CLOCK_TICK */
  556.     "dead-continuation",    /* DEAD_CONTINUATION */
  557.     "dead-thread",        /* DEAD_THREAD */
  558.     "thread-overflow",        /* THREAD_OVERFLOW */
  559.     "thread-underflow",        /* THREAD_UNDERFLOW */
  560.  
  561.     "cannot-make-array",    /* CANNOT_MAKE_ARRAY */
  562.     "cannot-make-character",    /* CANNOT_MAKE_CHARACTER */
  563.     "cannot-make-character_set", /* CANNOT_MAKE_CHARACTER_SET */
  564.     "cannot-make-float",    /* CANNOT_MAKE_FLOAT */
  565.     "cannot-make-number",    /* CANNOT_MAKE_NUMBER */
  566.     "cannot-make-pair",        /* CANNOT_MAKE_PAIR */
  567.     "cannot-make-readtable",    /* CANNOT_MAKE_READTABLE */
  568.     "cannot-make-stream",    /* CANNOT_MAKE_STREAM */
  569.     "cannot-make-string",    /* CANNOT_MAKE_STRING */
  570.     "cannot-make-symbol",    /* CANNOT_MAKE_SYMBOL */
  571.     "cannot-make-table",    /* CANNOT_MAKE_TABLE */
  572.     "cannot-make-thread",    /* CANNOT_MAKE_THREAD */
  573.  
  574.     "floating-overflow",    /* FLOATING_OVERFLOW */
  575.     "floating-underflow",    /* FLOATING_UNDERFLOW */
  576.     "integer-overflow",        /* INTEGER_OVERFLOW */
  577.     "integer-underflow",    /* INTEGER_UNDERFLOW */
  578.     "not-a-number",        /* NOT_A_NUMBER */
  579.  
  580.     "non-existent-file-or-device", /* NON_EXISTENT_FILE_OR_DEVICE */
  581.     "not-an-input-device",    /* NOT_AN_INPUT_DEVICE */
  582.     "not-an-input-stream",    /* NOT_AN_INPUT_STREAM */
  583.     "not-an-output-device",    /* NOT_AN_OUTPUT_DEVICE */
  584.     "cannot-access-file",    /* CANNOT_ACCESS_FILE */
  585.     "cannot-append-to-device",    /* CANNOT_APPEND_TO_DEVICE */        
  586.  
  587.     "slot-unbound",             /* SLOT_UNBOUND */
  588.     "slot-missing",             /* SLOT_MISSING */
  589.     "bad-slot-index",           /* BAD_SLOT_INDEX */
  590.     "no-lambda-list",           /* NON_LAMBDA_LIST */
  591.     "non-allocatable-object",   /* NON_ALLOCATABLE_OBJECT */
  592.     "no-applicable-method",     /* NO_APPLICABLE_METHOD */
  593.     "non-congruent-lambda-lists", /* NON_CONGRUENT_LAMBDA_LISTS */
  594.  
  595.     "cannot-make-vector",       /* CANNOT_MAKE_VECTOR */
  596.  
  597.     "heap-exhausted",           /* HEAP_EXHAUSTED */
  598.  
  599.     "uninitialized-lexical-variable", /* UNINITIALIZED_LEXICAL_VARIABLE */
  600.     "cannot-assign-variable",    /* CANNOT_ASSIGN_VARIABLE */
  601.     "invalid-operands",        /* INVALID_OPERANDS */
  602.     "immutable-location",    /* IMMUTABLE_LOCATION */
  603.     "cannot-modify-empty-list",    /* CANNOT_MODIFY_EMPTY_LIST */
  604.     "name-clash-in-module",    /* NAME_CLASH_IN_MODULE */
  605.     "cannot-unquote-splice",    /* CANNOT_UNQUOTE_SPLICE */
  606.     "semaphore-already-down",    /* SEMAPHORE_ALREADY_DOWN */
  607.     "cannot-make-function",    /* CANNOT_MAKE_FUNCTION */
  608.     "cannot-make-io-stream",    /* CANNOT_MAKE_IO_STREAM */
  609.     "cannot-make-structure-class", /* CANNOT_MAKE_STRUCTURE_CLASS */
  610.     "cannot-open-path",        /* CANNOT_OPEN_PATH */
  611.     "file-already-exists",    /* FILE_ALREADY_EXISTS */
  612.     "inconsistent-open-options", /* INCONSISTENT_OPEN_OPTIONS */
  613.     "invalid-stream-position",    /* INVALID_STREAM_POSITION */
  614.     "not-an-output-stream",    /* NOT_AN_OUTPUT_STREAM */
  615.     "not-an-io-stream",        /* NOT_AN_IO_STREAM */
  616.     "not-a-character-stream",    /* NOT_A_CHARACTER_STREAM */
  617.     "not-a-binary-stream",    /* NOT_A_BINARY_STREAM */
  618.     "not-a-positionable-stream", /* NOT_A_POSITIONABLE_STREAM */
  619.     "path-does-not-exist",    /* PATH_DOES_NOT_EXIST */
  620.     "stream-not-open",        /* STREAM_NOT_OPEN */
  621.     "non-congruent-lambda-list", /* NON_CONGRUENT_LAMBDA_LIST */
  622.     "no-next-method",        /* NO_NEXT_METHOD */
  623.     "method-in-use",        /* METHOD_IN_USE */
  624.     "invalid-return-continuation", /* invalid-return-continuation */
  625.     "invalid-throw-continuation", /* invalid-throw-continuation */
  626.     "cannot-make-tokeniser",    /* cannot-make-tokeniser */
  627.     "bad-method-class",        /* bad-method-class */
  628.  
  629.     0
  630.   };
  631.   int i;
  632.  
  633.   /* Initialise condition metaclass */
  634.  
  635.   Condition_Class = (LispObject) allocate_class(stacktop,NULL);
  636.   add_root(&Condition_Class);
  637.   make_class( stacktop,
  638.           Condition_Class,
  639.          "condition-class",
  640.           Standard_Class,
  641.           Standard_Class, 0 );
  642.   
  643.   Default_Condition = (LispObject) allocate_class(stacktop,NULL);
  644.   add_root(&Default_Condition);
  645.   make_class( stacktop,
  646.           Default_Condition,
  647.          "condition",
  648.           Condition_Class,
  649.           Object, N_SLOTS_IN_CONDITION);
  650.  
  651.   defined_conditions=allocate_vector(stacktop,99);
  652.   add_root(&defined_conditions);
  653.  
  654.   for (i=0; inits[i]; i++) {
  655.     LispObject cond_class;
  656.     vref(defined_conditions,i) = (LispObject) get_symbol(stacktop,inits[i]);
  657.  
  658.     gen_class(stacktop,&cond_class,inits[i],Condition_Class,
  659.           Default_Condition);
  660.     vref(defined_conditions,i)->SYMBOL.lvalue = cond_class;
  661.  
  662. #if 0
  663.       cond_class = allocate_class(stacktop,Condition_Class);
  664.     cond_class->CLASS.superclasses = EUCALL_2(Fn_cons,Default_Condition,nil);
  665.     Default_Condition->CLASS.subclasses =
  666.       EUCALL_2(Fn_cons,cond_class,Default_Condition->CLASS.subclasses);
  667.     cond_class->CLASS.name = defined_conditions[i];
  668. #endif
  669.  
  670.   }
  671.  
  672.   /* Rig heap failure condition... */
  673.  
  674.   condition_heap_exhausted = 
  675.     (LispObject) 
  676.       allocate_instance(stacktop,
  677.              vref(defined_conditions,HEAP_EXHAUSTED)->SYMBOL.lvalue);
  678.  
  679.   add_root(&condition_heap_exhausted);
  680.   sym_pling_backtrace = get_symbol(stacktop,"!backtrace");
  681.   add_root(&sym_pling_backtrace);
  682.   sym_pling_b = get_symbol(stacktop,"!b");
  683.   add_root(&sym_pling_b);
  684.   sym_pling_quickie = get_symbol(stacktop,"!quickie");
  685.   add_root(&sym_pling_quickie);
  686.   sym_pling_q = get_symbol(stacktop,"!q");
  687.   add_root(&sym_pling_q);
  688.   sym_pling_exit = get_symbol(stacktop,"!exit");
  689.   add_root(&sym_pling_exit);
  690.   sym_pling_root = get_symbol(stacktop,"!root");
  691.   add_root(&sym_pling_root);
  692.  
  693.   open_module(stacktop,
  694.           &Module_errors,
  695.           Module_errors_values,
  696.           "errors",
  697.           ERRORS_ENTRIES);
  698.  
  699.   (void) make_module_function(stacktop,"conditionp",Fn_conditionp,1);
  700.  
  701.   (void) make_module_function(stacktop,"make-condition",Fn_make_condition,-2);
  702.  
  703.   (void) make_module_function(stacktop,"condition-name",Fn_condition_name,1);
  704.   (void) make_module_function(stacktop,"condition-message",Fn_condition_message,1);
  705.   (void) make_module_function(stacktop,"condition-error-value",
  706.                   Fn_condition_error_value,1);
  707.  
  708.   (void) make_module_function(stacktop,"signal",Fn_signal,2);
  709.  
  710.   function_bootstrap_handler
  711.     = make_unexported_module_function(stacktop,"bootstrap-handler",
  712.                       Fn_bootstrap_handler,2);
  713.   add_root(&function_bootstrap_handler);
  714.   function_default_handler 
  715.     = make_unexported_module_function(stacktop,"default-handler",Fn_default_handler,2);
  716.   add_root(&function_default_handler);
  717.  
  718.   (void) make_module_function(stacktop,"error",Fn_error,-3);
  719.   (void) make_module_function(stacktop,"cerror",Fn_cerror,-3);
  720.  
  721.   close_module();
  722. }
  723.  
  724.